home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASWIZ20 / EXTMATH.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-04  |  21KB  |  854 lines

  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1994  Thomas G. Hanlin III         |
  4.     |                                                                      |
  5.     +----------------------------------------------------------------------+
  6.  
  7.  
  8.  
  9. Extended math:
  10.  
  11.    This unit contains procedures and functions that implement extensions to
  12.    Pascal's built-in math (new trig functions, et al) and an arithmetic
  13.    expression evaluator.  The latter is loosely based on EXPR.C from Dr.
  14.    Dobb's Journal, Sept 1985, p.25.
  15.  
  16. }
  17.  
  18. UNIT ExtMath;
  19.  
  20. INTERFACE
  21.  
  22. FUNCTION ArcCos (Number: Real): Real;
  23. FUNCTION ArcCosH (Number: Real): Real;
  24. FUNCTION ArcCot (Number: Real): Real;
  25. FUNCTION ArcCotH (Number: Real): Real;
  26. FUNCTION ArcCsc (Number: Real): Real;
  27. FUNCTION ArcCscH (Number: Real): Real;
  28. FUNCTION ArcSec (Number: Real): Real;
  29. FUNCTION ArcSecH (Number: Real): Real;
  30. FUNCTION ArcSin (Number: Real): Real;
  31. FUNCTION ArcSinH (Number: Real): Real;
  32. FUNCTION ArcTanH (Number: Real): Real;
  33. FUNCTION Ceil (Number: Real): Real;
  34. FUNCTION CosH (Number: Real): Real;
  35. FUNCTION Cot (Number: Real): Real;
  36. FUNCTION CotH (Number: Real): Real;
  37. FUNCTION Csc (Number: Real): Real;
  38. FUNCTION CscH (Number: Real): Real;
  39. FUNCTION Deg2Rad (Number: Real): Real;
  40. FUNCTION e: Real;
  41. FUNCTION Erf (Number: Real): Real;
  42. FUNCTION Fact (Number: Integer): Real;
  43. FUNCTION Floor (Number: Real): Real;
  44. FUNCTION Log (Number: Real): Real;
  45. FUNCTION Rad2Deg (Number: Real): Real;
  46. FUNCTION Raise (Number: Real; Power: Integer): Real;
  47. FUNCTION Sec (Number: Real): Real;
  48. FUNCTION SecH (Number: Real): Real;
  49. FUNCTION SgnI (Number: Integer): Integer;
  50. FUNCTION SgnR (Number: Real): Integer;
  51. FUNCTION SinH (Number: Real): Real;
  52. FUNCTION Tan (Number: Real): Real;
  53. FUNCTION TanH (Number: Real): Real;
  54.  
  55. PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
  56.  
  57.  
  58.  
  59. { --------------------------------------------------------------------------- }
  60.  
  61.  
  62.  
  63. IMPLEMENTATION
  64.  
  65. { forward declarations for the Evaluate procedure }
  66. FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  67. FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  68. FUNCTION IsDigit (Expr: String): Boolean; FORWARD;
  69. FUNCTION Locase (Ch: Char): Char; FORWARD;
  70. FUNCTION ParensOk (Expr: String): Boolean; FORWARD;
  71. FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real; FORWARD;
  72. PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer); FORWARD;
  73. PROCEDURE FixPrecedence (VAR Expr: String); FORWARD;
  74.  
  75.  
  76.  
  77. { ----- Ceiling ----- }
  78. FUNCTION Ceil (Number: Real): Real;
  79. BEGIN
  80.    IF Number = INT(Number) THEN
  81.       Ceil := Number
  82.    ELSE
  83.       Ceil := INT(Number) + 1.0;
  84. END;
  85.  
  86.  
  87.  
  88. { ----- Floor ----- }
  89. FUNCTION Floor (Number: Real): Real;
  90. BEGIN
  91.    IF Number = INT(Number) THEN
  92.       Floor := Number
  93.    ELSE
  94.       Floor := INT(Number) - 1.0;
  95. END;
  96.  
  97.  
  98.  
  99. { ----- Inverse cosine ----- }
  100. FUNCTION ArcCos (Number: Real): Real;
  101. BEGIN
  102.    IF (Number < -1.0) OR (Number > 1.0) THEN      { error }
  103.       ArcCos := 99999.0
  104.    ELSE
  105.       ArcCos := PI / 2.0 - ArcSin(Number);
  106. END;
  107.  
  108.  
  109.  
  110. { ----- Inverse hyperbolic cosine ----- }
  111. FUNCTION ArcCosH (Number: Real): Real;
  112. BEGIN
  113.    ArcCosH := Log(Number + SQRT(SQR(Number) - 1.0));
  114. END;
  115.  
  116.  
  117.  
  118. { ----- Inverse cotangent ----- }
  119. FUNCTION ArcCot (Number: Real): Real;
  120. BEGIN
  121.    ArcCot := -ARCTAN(Number) + PI / 2.0;
  122. END;
  123.  
  124.  
  125.  
  126. { ----- Inverse hyperbolic cotangent ----- }
  127. FUNCTION ArcCotH (Number: Real): Real;
  128. BEGIN
  129.    ArcCotH := LN((Number + 1.0) / (Number - 1.0)) / 2.0;
  130. END;
  131.  
  132.  
  133.  
  134. { ----- Inverse cosecant ----- }
  135. FUNCTION ArcCsc (Number: Real): Real;
  136. BEGIN
  137.    ArcCsc := ARCTAN(1.0 / SQRT(1.0 - SQR(Number)))
  138.       + (SgnR(Number) - 1.0) * (PI / 2.0);
  139. END;
  140.  
  141.  
  142.  
  143. { ----- Inverse hyperbolic cosecant ----- }
  144. FUNCTION ArcCscH (Number: Real): Real;
  145. BEGIN
  146.    ArcCscH := LN((SgnR(Number) * SQRT(SQR(Number) + 1.0) + 1.0) / Number);
  147. END;
  148.  
  149.  
  150.  
  151. { ----- Inverse secant ----- }
  152. FUNCTION ArcSec (Number: Real): Real;
  153. BEGIN
  154.    ArcSec := ARCTAN(Number / SQRT(1.0 - SQR(Number)))
  155.       + (SgnR(Number) - 1.0) * (PI / 2.0);
  156. END;
  157.  
  158.  
  159.  
  160. { ----- Inverse hyperbolic secant ----- }
  161. FUNCTION ArcSecH (Number: Real): Real;
  162. BEGIN
  163.    ArcSecH := LN((SQRT(1.0 - SQR(Number)) + 1.0) / Number);
  164. END;
  165.  
  166.  
  167.  
  168. { ----- Inverse sine ----- }
  169. FUNCTION ArcSin (Number: Real): Real;
  170. VAR
  171.    Negate: Boolean;
  172.    tmp: Real;
  173. BEGIN
  174.    IF Number < 0.0 THEN BEGIN
  175.       Number := -Number;
  176.       Negate := TRUE;
  177.    END
  178.    ELSE
  179.       Negate := FALSE;
  180.    IF Number > 1.0 THEN BEGIN
  181.       tmp := 99999.0;
  182.       Negate := FALSE;
  183.    END
  184.    ELSE BEGIN
  185.       tmp := SQRT(1.0 - SQR(Number));
  186.       IF Number > 0.7 THEN
  187.          tmp := PI / 2.0 - ARCTAN(tmp / Number)
  188.       ELSE
  189.          tmp := ARCTAN(Number / tmp);
  190.    END;
  191.    IF Negate THEN
  192.       ArcSin := -tmp
  193.    ELSE
  194.       ArcSin := tmp;
  195. END;
  196.  
  197.  
  198.  
  199. { ----- Inverse hyperbolic sine ----- }
  200. FUNCTION ArcSinH (Number: Real): Real;
  201. BEGIN
  202.    ArcSinH := Log(Number + SQRT(SQR(Number) + 1.0));
  203. END;
  204.  
  205.  
  206.  
  207. { ----- Inverse hyperbolic tangent ----- }
  208. FUNCTION ArcTanH (Number: Real): Real;
  209. BEGIN
  210.    ArcTanH := Log((1.0 + Number) / (1.0 - Number)) / 2.0;
  211. END;
  212.  
  213.  
  214.  
  215. { ----- Convert degrees to radians ----- }
  216. FUNCTION Deg2Rad (Number: Real): Real;
  217. BEGIN
  218.    Deg2Rad := Number * PI / 180.0;
  219. END;
  220.  
  221.  
  222.  
  223. { ----- e (base of the natural logarithms) ----- }
  224. FUNCTION e: Real;
  225. BEGIN
  226.    e := 2.7182818284590452353602874713526624977572470936999595749669676;
  227. END;
  228.  
  229.  
  230.  
  231. { ----- Hyperbolic cosine ----- }
  232. FUNCTION CosH (Number: Real): Real;
  233. BEGIN
  234.    IF Number < 0.0 THEN
  235.       Number := - Number;
  236.    IF Number > 21.0 THEN
  237.       CosH := Exp(Number) / 2.0
  238.    ELSE
  239.       CosH := (Exp(Number) + Exp(-Number)) / 2.0;
  240. END;
  241.  
  242.  
  243.  
  244. { ----- Cotangent ----- }
  245. FUNCTION Cot (Number: Real): Real;
  246. BEGIN
  247.    Cot := 1.0 / Tan(Number);
  248. END;
  249.  
  250.  
  251.  
  252. { ----- Hyperbolic cotangent ----- }
  253. FUNCTION CotH (Number: Real): Real;
  254. VAR
  255.    tmp: REAL;
  256. BEGIN
  257.    tmp := EXP(-Number);
  258.    CotH := tmp / (EXP(Number) - tmp) * 2.0 + 1.0;
  259. END;
  260.  
  261.  
  262.  
  263. { ----- Cosecant ----- }
  264. FUNCTION Csc (Number: Real): Real;
  265. BEGIN
  266.    Csc := 1.0 / Sin(Number);
  267. END;
  268.  
  269.  
  270.  
  271. { ----- Hyperbolic cosecant ----- }
  272. FUNCTION CscH (Number: Real): Real;
  273. BEGIN
  274.    CscH := 2.0 / (EXP(Number) - EXP(-Number));
  275. END;
  276.  
  277.  
  278.  
  279. { ----- Error Function ----- }
  280. FUNCTION Erf (Number: Real): Real;
  281. VAR
  282.    J, N: Integer;
  283.    S: Real;
  284. BEGIN
  285.    N := Trunc(14.0 * Number + 3.0);
  286.    S := 1.0 / (2.0 * N - 1.0);
  287.    FOR J := N - 1 DOWNTO 1 DO
  288.       S := 1.0 / (2.0 * J - 1.0) - SQR(Number) / J * S;
  289.    Erf := Number / 0.8862269254527581 * S;
  290. END;
  291.  
  292.  
  293.  
  294. { ----- Factorial ----- }
  295. FUNCTION Fact (Number: Integer): Real;
  296. VAR
  297.    Result: Real;
  298.    tmp: Integer;
  299. BEGIN
  300.    Result := 1.0;
  301.    FOR tmp := 2 TO Number DO
  302.       Result := Result * tmp;
  303.    Fact := Result;
  304. END;
  305.  
  306.  
  307.  
  308. { ----- Logarithm (base 10) ----- }
  309. FUNCTION Log (Number: Real): Real;
  310. BEGIN
  311.    Log := Ln(Number) / Ln(10.0);
  312. END;
  313.  
  314.  
  315.  
  316. { ----- Convert radians to degrees ----- }
  317. FUNCTION Rad2Deg (Number: Real): Real;
  318. BEGIN
  319.    Rad2Deg := Number * 180.0 / PI;
  320. END;
  321.  
  322.  
  323.  
  324. { ----- Raise a number to a power (a feature oddly lacking in Pascal). }
  325. FUNCTION Raise (Number: Real; Power: Integer): Real;
  326. VAR
  327.    tmp: Integer;
  328.    Result: Real;
  329. BEGIN
  330.    Result := 1.0;
  331.    FOR tmp := 1 TO Power DO
  332.       Result := Result * Number;
  333.    Raise := Result;
  334. END;     { Raise }
  335.  
  336.  
  337.  
  338. { ----- Secant ----- }
  339. FUNCTION Sec (Number: Real): Real;
  340. BEGIN
  341.    Sec := 1.0 / Cos(Number);
  342. END;
  343.  
  344.  
  345.  
  346. { ----- Hyperbolic secant ----- }
  347. FUNCTION SecH (Number: Real): Real;
  348. BEGIN
  349.    SecH := 2.0 / (EXP(Number) + EXP(-Number));
  350. END;
  351.  
  352.  
  353.  
  354. { ----- Signum (integer) ----- }
  355. FUNCTION SgnI (Number: Integer): Integer;
  356. BEGIN
  357.    IF Number < 0 THEN
  358.       SgnI := -1
  359.    ELSE IF Number > 0 THEN
  360.       SgnI := 1
  361.    ELSE
  362.       SgnI := 0;
  363. END;
  364.  
  365.  
  366.  
  367. { ----- Signum (real) ----- }
  368. FUNCTION SgnR (Number: Real): Integer;
  369. BEGIN
  370.    IF Number < 0.0 THEN
  371.       SgnR := -1
  372.    ELSE IF Number > 0.0 THEN
  373.       SgnR := 1
  374.    ELSE
  375.       SgnR := 0;
  376. END;
  377.  
  378.  
  379.  
  380. { ----- Hyperbolic sine ----- }
  381. FUNCTION SinH (Number: Real): Real;
  382. VAR
  383.    Negate: Boolean;
  384.    p0, p1, p2, p3, q0, q1, q2, tmp, tmp1, tmp2, tmpsq: Real;
  385. BEGIN
  386.    p0 := -630767.3640497716991184787251;
  387.    p1 := -89912.72022039509355398013511;
  388.    p2 := -2894.211355989563807284660366;
  389.    p3 := -26.30563213397497062819489;
  390.    q0 := -630767.3640497716991212077277;
  391.    q1 := 15215.17378790019070696485176;
  392.    q2 := -173.678953558233699533450911;
  393.    IF Number < 0.0 THEN BEGIN
  394.       Number := -Number;
  395.       Negate := TRUE;
  396.    END
  397.    ELSE
  398.       Negate := FALSE;
  399.    IF Number > 21.0 THEN
  400.       tmp := Exp(Number) / 2.0
  401.    ELSE IF Number > 0.5 THEN
  402.       tmp := (Exp(Number) - Exp(-Number)) / 2.0
  403.    ELSE BEGIN
  404.       tmpsq := SQR(Number);
  405.       tmp1 := (((tmpsq * p3 + p2) * tmpsq + p1) * tmpsq + p0) * Number;
  406.       tmp2 := ((tmpsq + q2) * tmpsq + q1) * tmpsq + q0;
  407.       tmp := tmp1 / tmp2;
  408.    END;
  409.    IF Negate THEN
  410.       SinH := -tmp
  411.    ELSE
  412.       SinH := tmp;
  413. END;
  414.  
  415.  
  416.  
  417. { ----- Tangent ----- }
  418. FUNCTION Tan (Number: Real): Real;
  419. BEGIN
  420.    Tan := Sin(Number) / Cos(Number);
  421. END;
  422.  
  423.  
  424.  
  425. { ----- Hyperbolic tangent ----- }
  426. FUNCTION TanH (Number: Real): Real;
  427. VAR
  428.    Negate: Boolean;
  429.    tmp: Real;
  430. BEGIN
  431.    IF Number < 0.0 THEN BEGIN
  432.       Number := -Number;
  433.       Negate := TRUE;
  434.    END
  435.    ELSE
  436.       Negate := FALSE;
  437.    IF Number > 21.0 THEN     { error }
  438.       TanH := 99999
  439.    ELSE BEGIN
  440.       tmp := SinH(Number) / CosH(Number);
  441.       IF Negate THEN
  442.          TanH := -tmp
  443.       ELSE
  444.          TanH := tmp;
  445.    END;
  446. END;
  447.  
  448.  
  449.  
  450. { =========================================================================== }
  451.  
  452.  
  453.  
  454. { ----- This is the main evaluation routine ----- }
  455. PROCEDURE Evaluate (Expr: String; VAR Result: Real; VAR ErrCode: Integer);
  456. VAR
  457.    tmp: Integer;
  458. BEGIN
  459.    WHILE (Pos(' ', Expr) > 0) DO
  460.       Delete(Expr, Pos(' ', Expr), 1);
  461.    WHILE (Pos('**', Expr) > 0) DO BEGIN
  462.       tmp := Pos('**', Expr);
  463.       Delete(Expr, tmp, 1);
  464.       Expr[tmp] := '^';
  465.    END;
  466.    IF Length(Expr) > 0 THEN
  467.       IF ParensOk(Expr) THEN BEGIN
  468.          FOR tmp := 1 TO Length(Expr) DO
  469.             Expr[tmp] := Upcase(Expr[tmp]);
  470.          ErrCode := 0;
  471.          FixPrecedence(Expr);
  472.          Result := Eval(Expr, ErrCode);
  473.       END
  474.       ELSE
  475.          ErrCode := 4
  476.    ELSE
  477.       ErrCode := 8;
  478. END;     { Evaluate }
  479.  
  480.  
  481.  
  482. { ----- This adds parentheses to force evaluation by normal algebraic
  483.         precedence (negation, exponentiation, multiplication and division,
  484.         addition and subtraction) }
  485. PROCEDURE AddParen (VAR Expr: String; Posn, WhichWay: Integer);
  486. VAR
  487.    Done: Boolean;
  488.    ch: Char;
  489.    Depth: Integer;
  490. BEGIN
  491.    Done := FALSE;
  492.    IF WhichWay < 0 THEN BEGIN
  493.       REPEAT
  494.          Dec(Posn);
  495.          IF Posn < 1 THEN BEGIN
  496.             Expr := '(' + Expr;
  497.             Done := TRUE;
  498.          END
  499.          ELSE BEGIN
  500.             ch := Expr[Posn];
  501.             IF Pos(ch, '^*/+-') > 0 THEN BEGIN
  502.                Insert('(', Expr, Posn + 1);
  503.                Done := TRUE;
  504.             END
  505.             ELSE IF ch = ')' THEN BEGIN
  506.                Depth := 1;
  507.                REPEAT
  508.                   Dec(Posn);
  509.                   IF Posn > 0 THEN BEGIN
  510.                      ch := Expr[Posn];
  511.                      IF ch = '(' THEN
  512.                         Dec(Depth)
  513.                      ELSE IF ch = ')' THEN
  514.                         Inc(Depth);
  515.                   END
  516.                   ELSE
  517.                      Depth := 0;
  518.                UNTIL Depth = 0;
  519.                IF Posn < 1 THEN
  520.                   Posn := 1;
  521.                Insert('(', Expr, Posn + 1);
  522.                Done := TRUE;
  523.             END;
  524.          END;
  525.       UNTIL Done;
  526.    END
  527.    ELSE
  528.       REPEAT
  529.          Inc(Posn);
  530.          IF Posn > Length(Expr) THEN BEGIN
  531.             Expr := Expr + ')';
  532.             Done := TRUE;
  533.          END
  534.          ELSE BEGIN
  535.             ch := Expr[Posn];
  536.             IF Pos(ch, '^*/+-') > 0 THEN BEGIN
  537.                Insert(')', Expr, Posn);
  538.                Done := TRUE;
  539.             END
  540.             ELSE IF ch = '(' THEN BEGIN
  541.                Depth := 1;
  542.                REPEAT
  543.                   Inc(Posn);
  544.                   IF Posn <= Length(Expr) THEN BEGIN
  545.                      ch := Expr[Posn];
  546.                      IF ch = ')' THEN
  547.                         Dec(Depth)
  548.                      ELSE IF ch = '(' THEN
  549.                         Inc(Depth);
  550.                   END
  551.                   ELSE
  552.                      Depth := 0;
  553.                UNTIL Depth = 0;
  554.                IF Posn > Length(Expr) THEN
  555.                   Posn := Length(Expr);
  556.                Insert(')', Expr, Posn);
  557.                Done := TRUE;
  558.             END;
  559.          END;
  560.       UNTIL Done;
  561. END;    { AddParen }
  562.  
  563.  
  564.  
  565. { ----- This recursive function is the heart of the expression evaluator. }
  566. FUNCTION Eval (VAR Expr: String; VAR ErrCode: Integer): Real;
  567. VAR
  568.    LVal, tmp: Real;
  569. BEGIN
  570.    LVal := Factor(Expr, ErrCode);
  571.    IF ErrCode = 0 THEN
  572.       CASE Expr[1] OF
  573.          '+': BEGIN
  574.                  Delete(Expr, 1, 1);
  575.                  LVal := LVal + Eval(Expr, ErrCode);
  576.               END;
  577.          '-': BEGIN
  578.                  Delete(Expr, 1, 1);
  579.                  LVal := LVal - Eval(Expr, ErrCode);
  580.               END;
  581.          '*': BEGIN
  582.                  Delete(Expr, 1, 1);
  583.                  LVal := LVal * Eval(Expr, ErrCode);
  584.               END;
  585.          '/': BEGIN
  586.                  Delete(Expr, 1, 1);
  587.                  tmp := Eval(Expr, ErrCode);
  588.                  IF ErrCode = 0 THEN
  589.                     IF tmp = 0.0 THEN
  590.                        ErrCode := 9
  591.                     ELSE
  592.                        LVal := LVal / tmp;
  593.               END;
  594.          '^': BEGIN
  595.                  Delete(Expr, 1, 1);
  596.                  LVal := Raise(LVal, Trunc(Eval(Expr, ErrCode)));
  597.               END;
  598.          ')': Delete(Expr, 1, 1);
  599.       END;     { CASE }
  600.    Eval := LVal;
  601. END;     { Eval }
  602.  
  603.  
  604.  
  605. { ----- A recursive evaluation helper, this function gets the leftmost term
  606.         that can be dealt with at this point in the evaluation. }
  607. FUNCTION Factor (VAR Expr: String; VAR ErrCode: Integer): Real;
  608. VAR
  609.    Negate: Boolean;
  610.    RVal: Real;
  611. BEGIN
  612.    RVal := 0.0;
  613.    IF Expr[1] = '-' THEN BEGIN
  614.       Negate := TRUE;
  615.       Delete(Expr, 1, 1);
  616.    END
  617.    ELSE
  618.       Negate := FALSE;
  619.    IF Expr[1] <> '(' THEN
  620.       RVal := Term(Expr, ErrCode)
  621.    ELSE BEGIN
  622.       Delete(Expr, 1, 1);
  623.       RVal := Eval(Expr, ErrCode);
  624.    END;
  625.    IF Negate THEN
  626.       Factor := -RVal
  627.    ELSE
  628.       Factor := RVal;
  629. END;     { Factor }
  630.  
  631.  
  632.  
  633. { ----- Since the evaluation function doesn't naturally evaluate expressions
  634.         using algebraic precedence, but does understand parentheses...
  635.         This routine adds parentheses to force the proper precedence. }
  636. PROCEDURE FixPrecedence (VAR Expr: String);
  637. VAR
  638.    Posn, tmp: Integer;
  639. BEGIN
  640.    Expr := '(' + Expr + ')';
  641.    Posn := 2;
  642.    REPEAT
  643.       IF Expr[Posn] = '-' THEN
  644.          IF NOT(Expr[Posn - 1] IN ['0'..'9','A'..'Z']) THEN BEGIN
  645.             AddParen(Expr, Posn, 1);
  646.             AddParen(Expr, Posn, -1);
  647.             Inc(Posn, 2);
  648.          END
  649.          ELSE
  650.             Inc(Posn)
  651.       ELSE
  652.          Inc(Posn);
  653.    UNTIL Posn > Length(Expr);
  654.    Posn := 1;
  655.    REPEAT
  656.       IF Expr[Posn] <> Locase(Expr[Posn]) THEN BEGIN
  657.          AddParen(Expr, Posn, 1);
  658.          AddParen(Expr, Posn, -1);
  659.          Inc(Posn, 2);
  660.       END
  661.       ELSE
  662.          Inc(Posn);
  663.    UNTIL Posn > Length(Expr);
  664.    Posn := 1;
  665.    REPEAT
  666.       IF Expr[Posn] = '^' THEN BEGIN
  667.          AddParen(Expr, Posn, 1);
  668.          AddParen(Expr, Posn, -1);
  669.          Inc(Posn, 2);
  670.       END
  671.       ELSE
  672.          Inc(Posn);
  673.    UNTIL Posn > Length(Expr);
  674.    Posn := 1;
  675.    REPEAT
  676.       IF Pos(Expr[Posn], '*/') > 0 THEN BEGIN
  677.          AddParen(Expr, Posn, 1);
  678.          AddParen(Expr, Posn, -1);
  679.          Inc(Posn, 2);
  680.       END
  681.       ELSE
  682.          Inc(Posn);
  683.    UNTIL Posn > Length(Expr);
  684.    Posn := 1;
  685.    REPEAT
  686.       IF Pos(Expr[Posn], '+-') > 0 THEN BEGIN
  687.          AddParen(Expr, Posn, 1);
  688.          AddParen(Expr, Posn, -1);
  689.          Inc(Posn, 2);
  690.       END
  691.       ELSE
  692.          Inc(Posn);
  693.    UNTIL Posn > Length(Expr);
  694.    Delete(Expr, 1, 1);
  695.    Delete(Expr, Length(Expr), 1);
  696. END;     { FixPrecedence }
  697.  
  698.  
  699.  
  700. { ----- Determine whether a character may be construed as being numeric. }
  701. FUNCTION IsDigit (Expr: String): Boolean;
  702. BEGIN
  703.    IF Length(Expr) > 0 THEN
  704.       IsDigit := (Pos(Expr[1], '0123456789.') > 0)
  705.    ELSE
  706.       IsDigit := FALSE;
  707. END;     { IsDigit }
  708.  
  709.  
  710.  
  711. { ----- Convert a character to lowercase. }
  712. FUNCTION LoCase (ch: Char): Char;
  713. BEGIN
  714.    IF ch IN ['A'..'Z'] THEN
  715.       LoCase := CHR(ORD(ch) XOR 32)
  716.    ELSE
  717.       LoCase := ch
  718. END;     { LoCase }
  719.  
  720.  
  721.  
  722. { ----- Check to make sure parentheses are balanced. }
  723. FUNCTION ParensOk (Expr: String): Boolean;
  724. VAR
  725.    Parens, Posn: Integer;
  726. BEGIN
  727.    Parens := 0;
  728.    FOR Posn := 1 TO Length(Expr) DO
  729.       IF Expr[Posn] = '(' THEN
  730.          Inc(Parens)
  731.       ELSE IF Expr[Posn] = ')' THEN
  732.          Dec(Parens);
  733.    ParensOk := (Parens = 0);
  734. END;     { ParensOk }
  735.  
  736.  
  737.  
  738. { ----- This grabs a number from the expression. }
  739. FUNCTION Term (VAR Expr: String; VAR ErrCode: Integer): Real;
  740. VAR
  741.    junk: Integer;
  742.    RVal: Real;
  743.    ch: char;
  744.    tmp: String;
  745. BEGIN
  746.    RVal := 0.0;
  747.    ch := Upcase(Expr[1]);
  748.    IF ch <> Locase(ch) THEN BEGIN
  749.       tmp := '';
  750.       REPEAT
  751.          tmp := tmp + ch;
  752.          Delete(Expr, 1, 1);
  753.          ch := Upcase(Expr[1]);
  754.       UNTIL (ch = Locase(ch)) OR (Length(Expr) = 0);
  755.       IF tmp = 'ABS' THEN
  756.          IF ch = '(' THEN BEGIN
  757.             Delete(Expr, 1, 1);
  758.             RVal := ABS(Eval(Expr, ErrCode))
  759.          END
  760.          ELSE
  761.             ErrCode := 1
  762.       ELSE IF tmp = 'ACOS' THEN
  763.          IF ch = '(' THEN BEGIN
  764.             Delete(Expr, 1, 1);
  765.             RVal := ArcCos(Eval(Expr, ErrCode))
  766.          END
  767.          ELSE
  768.             ErrCode := 1
  769.       ELSE IF tmp = 'ASIN' THEN
  770.          IF ch = '(' THEN BEGIN
  771.             Delete(Expr, 1, 1);
  772.             RVal := ArcSin(Eval(Expr, ErrCode))
  773.          END
  774.          ELSE
  775.             ErrCode := 1
  776.       ELSE IF tmp = 'ATAN' THEN
  777.          IF ch = '(' THEN BEGIN
  778.             Delete(Expr, 1, 1);
  779.             RVal := ARCTAN(Eval(Expr, ErrCode))
  780.          END
  781.          ELSE
  782.             ErrCode := 1
  783.       ELSE IF tmp = 'COS' THEN
  784.          IF ch = '(' THEN BEGIN
  785.             Delete(Expr, 1, 1);
  786.             RVal := COS(Eval(Expr, ErrCode))
  787.          END
  788.          ELSE
  789.             ErrCode := 1
  790.       ELSE IF tmp = 'FRAC' THEN
  791.          IF ch = '(' THEN BEGIN
  792.             Delete(Expr, 1, 1);
  793.             RVal := Eval(Expr, ErrCode);
  794.             RVal := RVal - INT(RVal);
  795.          END
  796.          ELSE
  797.             ErrCode := 1
  798.       ELSE IF tmp = 'INT' THEN
  799.          IF ch = '(' THEN BEGIN
  800.             Delete(Expr, 1, 1);
  801.             RVal := INT(Eval(Expr, ErrCode))
  802.          END
  803.          ELSE
  804.             ErrCode := 1
  805.       ELSE IF tmp = 'LOG' THEN
  806.          IF ch = '(' THEN BEGIN
  807.             Delete(Expr, 1, 1);
  808.             RVal := LOG(Eval(Expr, ErrCode))
  809.          END
  810.          ELSE
  811.             ErrCode := 1
  812.       ELSE IF tmp = 'PI' THEN
  813.          RVal := 3.141593
  814.       ELSE IF tmp = 'SIN' THEN
  815.          IF ch = '(' THEN BEGIN
  816.             Delete(Expr, 1, 1);
  817.             RVal := SIN(Eval(Expr, ErrCode))
  818.          END
  819.          ELSE
  820.             ErrCode := 1
  821.       ELSE IF tmp = 'SQRT' THEN
  822.          IF ch = '(' THEN BEGIN
  823.             Delete(Expr, 1, 1);
  824.             RVal := SQRT(Eval(Expr, ErrCode))
  825.          END
  826.          ELSE
  827.             ErrCode := 1
  828.       ELSE IF tmp = 'TAN' THEN
  829.          IF ch = '(' THEN BEGIN
  830.             Delete(Expr, 1, 1);
  831.             RVal := TAN(Eval(Expr, ErrCode))
  832.          END
  833.          ELSE
  834.             ErrCode := 1
  835.       ELSE
  836.          ErrCode := 3
  837.    END
  838.    ELSE IF IsDigit(Expr) THEN BEGIN
  839.       tmp := '';
  840.       WHILE IsDigit(Expr) DO BEGIN
  841.          tmp := tmp + Expr[1];
  842.          Delete(Expr, 1, 1);
  843.       END;
  844.       Val(tmp, RVal, junk);
  845.    END
  846.    ELSE
  847.       ErrCode := 2;
  848.    Term := RVal;
  849. END;     { Term }
  850.  
  851.  
  852.  
  853. END.     { ExtMath UNIT }
  854.